home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / EXEC.SEQ < prev    next >
Text File  |  1988-06-24  |  7KB  |  194 lines
  1. \ EXEC.SEQ      A utility for calling DOS from Forth.   by Tom Zimmer
  2.  
  3. only forth also hidden also definitions
  4.  
  5. hex
  6.  
  7. create exec.param 10 allot      exec.param 10 erase
  8.  
  9. variable ss_save
  10. variable sp_save
  11.  
  12. code <exec>     ( string --- return-code )
  13.                 pop dx                          \ DX contains string
  14.                 push es                 push si
  15.                 push bp                 push ds
  16.                 mov ax, cs              mov es, ax
  17.                 mov bx, # exec.param
  18.                 mov ax, # 4B00
  19.                                                 \ Save Sp and SS
  20.                 mov sp_save sp          mov ss_save ss
  21.                 int 21
  22.                                                 \ Restore SP and SS
  23.                 mov cs: ss, ss_save     mov cs: sp, sp_save
  24.                 pop ds                  pop bp
  25.                 pop si                  pop es
  26.              U< IF                      \ ONLY when carry is NON ZERO
  27.                         AND AX, # $FF
  28.                 ELSE    MOV AX, # 0
  29.                 THEN
  30.                 PUSH AX
  31.                 JMP ' SET_VECTORS
  32.                 END-CODE
  33. \                1push end-code                  \ AX contains error code
  34.  
  35. decimal
  36.  
  37. handle cmdpath                  \ These two lines could be replaced with
  38.                                 \ CREATE CMDPATH ," \COMMAND.COM" 0 ,
  39. cmdpath !hcb \COMMAND.COM
  40.  
  41. : initcmdpath   ( --- )         \ Initialize the Command path
  42.                 defers initstuff
  43.                 comspec@ comspec$ cmdpath $>handle ;
  44.  
  45. ' initcmdpath is initstuff      \ Put into initialization chain.
  46.  
  47. : $sys          ( countedstring --- f1 ) \ spawn a shell
  48.                 exec.param 16 erase
  49.                 dup c@
  50.         if      count tuck pad 4 + swap cmove
  51.                 " /c " pad 1+ swap cmove
  52.                 3 + pad c! pad count + off
  53.         else    drop pad off
  54.         then    44 @    exec.param      !   \ environment segmnt
  55.                 ?cs:    exec.param  4 + !   \ command line seg
  56.                 pad     exec.param  2 + !   \ and offset
  57.                 $0D pad count + c!          \ append a carraige return
  58.                 cmdpath >nam
  59.                 RESTORE_VECTORS
  60.                 <exec> ;
  61.  
  62. : ?syserror     ( n1 --- )      \ handle ONLY error codes 2 and 8 from $sys
  63.                                   \ and -2 meaning wrong DOS version.
  64.                 dup  2 = abort" Can't find COMMAND.COM"
  65.                 dup  8 = abort" Not enough memory"
  66.                 drop ;
  67.  
  68. forth definitions
  69.  
  70. : sys           ( command --- )
  71.                 0  word cr $sys 0 24 AT cr ?syserror ;
  72.  
  73. ' SYS ALIAS `   ( command --- )
  74.  
  75. comment:
  76.  
  77. The SYS word relys on a string compiled in the handle CMDPATH, to
  78. contain the name and path to COMMAND.COM. For SYS to work, this string
  79. must specify the actual location of COMMAND.COM on your hard disk,
  80. or floppy. The drive may be omitted, which will cause SYS to look on
  81. the current drive.
  82.  
  83. comment;
  84.  
  85. hidden definitions
  86.  
  87. : cmdbuf        rp0 @ 100 - ;           \ Down from return stack,
  88.                                         \ yet above TIB.
  89.  
  90. : "syscommand   ( a1 n1 c1 --- )        \ pass string a1,n1 to dos with line
  91.                                         \ following appended to it.
  92.                 >r ">$ cmdbuf over c@ 1+ cmove
  93.                 r> word count dup >r cmdbuf count + swap cmove
  94.                 r> cmdbuf c@ + cmdbuf c!
  95.                 cmdbuf count + off
  96.                 cmdbuf $sys 0 24 at cr ?syserror ;
  97.  
  98. : dir.name      ( --- )
  99.                 tabsize @ >r 16 tabsize !
  100.                 #OUT @ 64 > IF CR THEN
  101.                 #out @ >r pad 30 + 12 bounds
  102.                 do      i c@ ?dup
  103.                         if emit else leave then
  104.                 loop    10 #out @ r> - - spaces
  105.                 pad 21 + c@ 16 and
  106.                 if      ." <DIR>"
  107.                 then    tab r> tabsize ! ;
  108.  
  109. : $dir          ( a1 --- )
  110.                 here over c@ 1+ cmove
  111.                 here pathset drop
  112.                 ."  For directory " here count type
  113.                 here count + off here 1+
  114.                 CR  PAD SET-DTA findfirst
  115.                 BEGIN   255 and 0=
  116.                 WHILE   dir.name findnext REPEAT  ;
  117.  
  118. forth definitions
  119.  
  120. : dir           ( <filespec> --- )      \ directory of <filespec>.
  121.                 " dir " 0 "syscommand ;
  122.  
  123. : del           ( <filespec> --- )      \ delete files
  124.                 " del " bl "syscommand ;
  125.  
  126. \ ' del alias delete
  127.  
  128. : chdir         ( <filespec> --- )      \ change directory
  129.                 " chdir " bl "syscommand shndl @ >hndle @ 0<
  130.                 IF      shndl @ dup clr-hcb pathset drop
  131.                         -2 shndl @ >hndle !
  132.                 THEN    ;
  133.  
  134. ' chdir alias cd        \ Watch OUT, this is also a HEX number.
  135.  
  136. : copy          ( <filespec> --- )      \ copy files
  137.                 " copy " 0 "syscommand ;
  138.  
  139. : ren           ( <filespec> --- )      \ rename files
  140.                 " ren " 0 "syscommand ;
  141.  
  142. ' ren alias rename
  143.  
  144. comment:
  145.  
  146. : "setdrive     ( a1 n1 --- )           \ set drive a as default drive.
  147.                 ">$ $sys ?syserror
  148.                 shndl @ >hndle @ -2 =
  149.                 if      -1 shndl @ >hndle !
  150.                 then    ;
  151.  
  152. : a:            ( --- )                 \ set drive b as default drive.
  153.                 " a:" "setdrive ;
  154.  
  155. : b:            ( --- )                 \ set drive b as default drive.
  156.                 " b:" "setdrive ;
  157.  
  158. : c:            ( --- )                 \ set drive c as default drive.
  159.                 " c:" "setdrive ;
  160.  
  161. comment;
  162.  
  163.                 \ Here are some additional system commands you can
  164.                   \ add if you need them. Just un-comment: them out.
  165. comment:
  166.  
  167. : rd            ( <filespec> --- )      \ remove directory
  168.                 " rd " bl "syscommand ;
  169.  
  170. ' rd alias rmdir
  171.  
  172. : md            ( <filespec> --- )      \ make directory
  173.                 " md " bl "syscommand ;
  174.  
  175. ' md alias mkdir
  176.  
  177. : format        ( <drivespec> --- )     \ format disk
  178.                 " format " bl "syscommand ;
  179.  
  180. : ftype         ( <filespec> --- )      \ type a file
  181.                 " type " bl "syscommand ;
  182.  
  183. : path          ( <pathspec> --- )      \ gt or set search path
  184.                 " path " bl "syscommand ;
  185.  
  186. : cls           ( --- )
  187.                 " cls " bl "syscommand ;
  188.  
  189. comment;
  190.  
  191. only forth also definitions
  192.  
  193.  
  194.